home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / DEFS2.LSP < prev    next >
Text File  |  1994-02-05  |  26KB  |  493 lines
  1. ;;; CLtL2-kompatible Definitionen
  2. ;;; Bruno Haible 9.9.1993
  3.  
  4. ; List of X3J13 votes and their current status in CLISP
  5. ;
  6. ; Number: from CLtL2, Index of X3J13 Votes.
  7. ; Status: indicates whether CLISP supports code that makes use of this vote.
  8. ;
  9. ; Number Title                               Status          Files affected
  10. ;
  11. ;   <1>  ADJUST-ARRAY displacement           yes             array.d
  12. ;   <2>  ADJUST-ARRAY :FILL-POINTER          yes             array.d
  13. ;   <3>  ADJUST-ARRAY not adjustable         no              array.d
  14. ;   <4>  allow local INLINE                  yes             compiler.lsp, init.lsp
  15. ;   <5>  APPLYHOOK environment               yes             eval.d
  16. ;   <6>  AREF 1D                             no              array.d
  17. ;   <7>  arguments underspecified            yes
  18. ;   <8>  array type/element type semantics   yes for arrays  type.lsp
  19. ;                                            no for complex numbers
  20. ;   <9>  ASSOC/RASSOC-IF :KEY                yes             list.d
  21. ;  <10>  *BREAK-ON-WARNINGS* obsolete        no              user1.lsp
  22. ;  <11>  character proposal                  no
  23. ;  <12>  CLOS                                yes (largely)   clos.lsp
  24. ;  <13>  CLOS macro compilation              yes             clos.lsp
  25. ;  <14>  CLOSE constructed stream            yes             stream.d
  26. ;  <15>  closed stream operations            yes             stream.d
  27. ;  <16>  colon-number                        yes             io.d
  28. ;  <17>  COMMON type                         no              predtype.d, type.lsp
  29. ;  <18>  COMPILE argument problems           yes             compiler.lsp
  30. ;  <19>  compile environment consistency     yes             compiler.lsp
  31. ;  <20>  COMPILE-FILE handling of top-level forms
  32. ;                                            yes             compiler.lsp
  33. ;  <21>  COMPILE-FILE & *PACKAGE*            yes             compiler.lsp
  34. ;  <22>  COMPILE-FILE symbol handling        yes             compiler.lsp
  35. ;  <23>  COMPILED-FUNCTION requirements      yes             compiler.lsp
  36. ;  <24>  compiler diagnostics                no              compiler.lsp
  37. ;  <25>  COMPILER-LET confusion              no              control.d, init.lsp, compiler.lsp
  38. ;  <26>  compiler verbosity                  no              compiler.lsp
  39. ;  <27>  compiler warning stream             yes             compiler.lsp
  40. ;  <28>  complex ATAN branch cut             yes             comptran.d
  41. ;  <28a> complex ATANH branch cut            yes             comptran.d
  42. ;  <29>  (COMPLEX RATIONAL) result           yes             compelem.d, comptran.d
  43. ;  <30>  condition system                    no              user1.lsp
  44. ;  <31>  condition restarts                  no              user1.lsp
  45. ;  <32>  constant circular compilation       yes             compiler.lsp
  46. ;  <33>  constant collapsing                 yes             compiler.lsp
  47. ;  <34>  constant compilable types           no for packages
  48. ;                                            yes for anything else
  49. ;  <35>  constant function compilation       yes
  50. ;  <36>  constant modification               yes
  51. ;  <37>  contagion on numerical comparisons  yes             realelem.d, flo_rest.d
  52. ;  <38>  COPY-SYMBOL copy plist              yes             defs1.lsp
  53. ;  <39>  COPY-SYMBOL print name              yes             defs1.lsp, package.d
  54. ;  <40>  data I/O                            no              io.d
  55. ;  <41>  data types hierarchy unspecified    yes             lispbibl.d
  56. ;  <42>  declaration scope                   no
  57. ;  <43>  declare array type & element references
  58. ;                                            yes
  59. ;  <44>  declare function ambiguity          yes
  60. ;  <45>  declare macros                      no              eval.d, compiler.lsp
  61. ;  <46>  declare type free                   yes
  62. ;  <47>  DECODE-UNIVERSAL-TIME daylight      yes             defs1.lsp
  63. ;  <48>  DEFCONSTANT special                 yes             control.d, compiler.lsp
  64. ;  <49>  DEFINE-COMPILER-MACRO               no              defs2.lsp
  65. ;  <50>  defining macros non top-level       no
  66. ;  <51>  DEFMACRO lambda-list                yes             defmacro.lsp
  67. ;  <52>  DEFPACKAGE                          yes             defs2.lsp
  68. ;  <53>  DEFSTRUCT constructor/key mixture   no              defstruc.lsp
  69. ;  <54>  DEFSTRUCT default value evaluation  yes             defstruc.lsp
  70. ;  <55>  DEFSTRUCT :PRINT-FUNCTION inheritance
  71. ;                                            no              defstruc.lsp
  72. ;  <56>  DEFSTRUCT redefinition              yes             defstruc.lsp
  73. ;  <57>  DEFSTRUCT slots constraints: name   no              defstruc.lsp
  74. ;  <58>  DEFSTRUCT slots constraints: number yes             defstruc.lsp
  75. ;  <59>  DEFVAR documentation                yes             macros1.lsp
  76. ;  <60>  DEFVAR init time                    yes             macros1.lsp
  77. ;  <61>  DEFVAR initialization               yes             macros1.lsp
  78. ;  <62>  DESCRIBE interactive                yes             user2.lsp
  79. ;  <63>  DESCRIBE underspecified             yes             user2.lsp, clos.lsp
  80. ;  <64>  DESTRUCTURING-BIND                  no              defmacro.lsp
  81. ;  <65>  DISASSEMBLE side effect             yes             compiler.lsp
  82. ;  <66>  DO-SYMBOLS duplicates               yes             defs1.lsp, package.d
  83. ;  <67>  dotted macro forms                  yes
  84. ;  <68>  DRIBBLE technique                   yes             user2.lsp
  85. ;  <69>  DYNAMIC-EXTENT                      no
  86. ;  <70>  DYNAMIC-EXTENT & function           no
  87. ;  <71>  EQUAL & structure                   yes for EQUAL   predtype.d
  88. ;                                            no for EQUALP
  89. ;  <72>  EVAL other                          no              eval.d, compiler.lsp
  90. ;  <73>  EVAL-WHEN non top-level             no              control.d, init.lsp, compiler.lsp
  91. ;  <74>  exit extent                         yes
  92. ;  <75>  EXPT & ratio                        yes             comptran.d
  93. ;  <76>  FIXNUM non-portable                 no              array.d
  94. ;  <77>  FLET declarations                   no
  95. ;  <78>  FLET implicit block                 no
  96. ;  <79>  float underflow                     no
  97. ;  <80>  FORMAT atsign & colon               yes             format.lsp
  98. ;  <81>  FORMAT colon uparrow scope          no              format.lsp
  99. ;  <82>  FORMAT comma-interval               no              format.lsp
  100. ;  <83>  FORMAT ~E exponent-sign             yes             format.lsp
  101. ;  <84>  FORMAT op C                         no              format.lsp
  102. ;  <85>  FORMAT & pretty print               yes             format.lsp
  103. ;                                            no: ~E, ~F, ~G, ~$ also bind *PRINT-BASE* to 10 and *PRINT-RADIX* to NIL
  104. ;  <86>  function call & evaluation order    yes
  105. ;  <87>  function composition                no              defs2.lsp
  106. ;  <88>  function definition                 yes             defs2.lsp
  107. ;  <89>  function name                       yes             control.d, places.lsp, compiler.lsp
  108. ;  <90>  FUNCTION type                       no              predtype.d, type.lsp, compiler.lsp
  109. ;  <91>  FUNCTION type: argument type semantics
  110. ;                                            yes
  111. ;  <92>  FUNCTION type: &KEY name            yes
  112. ;  <93>  FUNCTION type: &REST list element   yes
  113. ;  <94>  GENSYM name stickiness              no              symbol.d
  114. ;  <95>  GET-MACRO-CHARACTER readtable       no              io.d
  115. ;  <96>  GET-SETF-METHOD environment         yes             places.lsp
  116. ;  <97>  hash-table access                   no              hashtabl.d
  117. ;  <98>  hash-table & package generators     no              hashtabl.d, package.d, defs2.lsp
  118. ;  <99>  hash-table size                     yes             hashtabl.d
  119. ; <100>  hash-table tests                    no              hashtabl.d
  120. ; <101>  IEEE & ATAN branch cut              yes
  121. ; <102>  IMPORT & SETF SYMBOL-PACKAGE        no              package.d
  122. ; <103>  IN-PACKAGE functionality            no              package.d, compiler.lsp
  123. ; <104>  in syntax                           yes             init.lsp, compiler.lsp
  124. ; <105>  keyword argument name package       no
  125. ; <106>  LAST n                              no              list.d
  126. ; <107>  LCM no arguments                    yes             lisparit.d
  127. ; <108>  LISP package name                   no
  128. ; <109>  LISP symbol redefinition            yes
  129. ; <110>  LOAD & objects                      no
  130. ; <111>  LOAD-TIME-VALUE                     yes             control.d, init.lsp, compiler.lsp
  131. ; <112>  *LOAD-TRUENAME*                     no              init.lsp
  132. ; <113>  LOCALLY top level                   yes             control.d, init.lsp, compiler.lsp
  133. ; <114>  LOOP AND discrepancy                no              loop.lsp
  134. ; <115>  LOOP facility                       no              loop.lsp
  135. ; <116>  macro caching                       yes
  136. ; <117>  macro environment extent            yes
  137. ; <118>  MACRO-FUNCTION environment          no              control.d, compiler.lsp
  138. ; <119>  MAKE-PACKAGE :USE default           yes
  139. ; <120>  MAP-INTO                            no              sequence.d
  140. ; <121>  mapping & destructive: interaction  yes             sequence.d, list.d, hashtabl.d, package.d
  141. ; <122>  more character proposal             no              charstrg.d, stream.d
  142. ; <123>  NTH-VALUE                           yes             defs2.lsp
  143. ; <124>  OPTIMIZE DEBUG info                 yes             init.lsp
  144. ; <125>  package clutter                     no              init.lsp
  145. ; <126>  package deletion                    no              package.d
  146. ; <127>  package function consistency        no              package.d
  147. ; <128>  pathname: component case            no              pathname.d
  148. ; <129>  pathname: component value           no              pathname.d
  149. ; <130>  pathname: logical                   no              pathname.d
  150. ; <131>  pathname: print & read              no              io.d
  151. ; <132>  pathname: stream                    no              pathname.d, stream.d
  152. ; <133>  pathname: subdirectory list         no              pathname.d
  153. ; <134>  pathname: symbol                    no              pathname.d, stream.d
  154. ; <135>  pathname: syntax error time         yes             pathname.d
  155. ; <136>  pathname: unspecific component      no              pathname.d
  156. ; <137>  pathname: :WILD                     no              pathname.d
  157. ; <138>  PEEK-CHAR, READ-CHAR & echo         no              io.d, stream.d
  158. ; <139>  pretty-print interface              no              xp.lsp
  159. ; <140>  PRINC character                     yes             io.d
  160. ; <141>  *PRINT-CASE* / *PRINT-ESCAPE* interaction
  161. ;                                            no              io.d
  162. ; <142>  *PRINT-CIRCLE* shared               yes             io.d
  163. ; <143>  *PRINT-CIRCLE* structure            yes             io.d
  164. ; <144>  PROCLAIM etc. in COMPILE-FILE       yes             defs2.lsp
  165. ; <145>  PROCLAIM INLINE: where              yes             compiler.lsp
  166. ; <146>  PUSH & evaluation order             yes             places.lsp
  167. ; <147>  QUOTE semantics                     yes
  168. ; <148>  range of :COUNT keyword             no              sequence.d
  169. ; <149>  range of start and end parameters   yes             sequence.d
  170. ; <150>  READ: case sensitivity              yes             io.d
  171. ;                                            except for :INVERT
  172. ; <151>  REAL number type                    yes             predtype.d, type.lsp
  173. ; <152>  REDUCE argument extraction          no              sequence.d
  174. ; <153>  REMF & destruction: unspecified     no for NRECONC  list.d
  175. ;                                            yes for anything else
  176. ; <154>  REQUIRE pathname defaults           no              defs1.lsp
  177. ; <155>  &REST list allocation               yes             eval.d
  178. ; <156>  return values unspecified           yes             macros1.lsp, package.d, io.d
  179. ; <157>  ROOM :DEFAULT argument              no              debug.d
  180. ; <158>  sequence type & length              no              sequence.d, predtype.d
  181. ; <159>  SETF & multiple store variables     yes for SETF    places.lsp
  182. ;                                            no for SHIFTF, ROTATEF, ASSERT
  183. ; <160>  SETF & sub-methods                  yes             places.lsp
  184. ; <161>  SHADOW: already present             yes             package.d
  185. ; <162>  sharp-comma confusion               no              io.d
  186. ; <163>  sharpsign-plus/minus package        no              io.d, spvw.d, init.lsp, compiler.lsp
  187. ; <164>  special type-shadowing              yes
  188. ; <165>  *STANDARD-INPUT* initial binding    yes             stream.d
  189. ; <166>  STEP environment                    yes             user1.lsp, macros2.lsp
  190. ; <167>  stream access                       no              stream.d
  191. ; <168>  stream capabilities                 yes             stream.d
  192. ; <169>  string coercion                     yes             charstrg.d
  193. ; <170>  SUBSEQ out of bounds                yes             sequence.d
  194. ; <171>  SUBTYPEP too vague                  yes             type.lsp
  195. ; <172>  SYMBOL-MACROLET & DECLARE           yes             compiler.lsp
  196. ; <173>  SYMBOL-MACROLET semantics           yes             eval.d, control.d, init.lsp, compiler.lsp
  197. ; <174>  syntactic environment access        no
  198. ; <175>  TAILP & NIL                         yes             list.d
  199. ; <176>  :TEST-NOT, -IF-NOT                  no              sequence.d, list.d
  200. ; <177>  THE ambiguity                       yes
  201. ; <178>  time-zone non-integer               yes             defs1.lsp
  202. ; <179>  TYPE-OF underconstrained            yes             predtype.d
  203. ; <180>  undefined variables and functions   yes
  204. ; <181>  UNREAD-CHAR after PEEK-CHAR         yes             stream.d
  205. ; <182>  variable list asymmetry             yes             macros1.lsp
  206. ; <183>  WITH-COMPILATION-UNIT               no              compiler.lsp
  207. ; <184>  WITH-OPEN-FILE & does-not-exist     yes             macros2.lsp
  208. ; <185>  WITH-OUTPUT-TO-STRING append style  yes             macros2.lsp
  209. ; <186>  ZLOS conditions                     no              user1.lsp
  210.  
  211. ;===============================================================================
  212.  
  213. (in-package "LISP")
  214. (export '(nth-value function-lambda-expression defpackage define-symbol-macro
  215.           print-unreadable-object declaim
  216. )        )
  217. (in-package "SYSTEM")
  218.  
  219. ;-------------------------------------------------------------------------------
  220.  
  221. ;; X3J13 vote <123>
  222.  
  223. ;; Macro (nth-value n form) == (nth n (multiple-value-list form)), CLtL2 S. 184
  224. (defmacro nth-value (n form)
  225.   (if (and (integerp n) (>= n 0))
  226.     (if (< n (1- multiple-values-limit))
  227.       (if (= n 0)
  228.         `(PROG1 ,form)
  229.         (let ((resultvar (gensym)))
  230.           (do ((vars (list resultvar))
  231.                (ignores nil)
  232.                (i n (1- i)))
  233.               ((zerop i)
  234.                `(MULTIPLE-VALUE-BIND ,vars ,form
  235.                   (DECLARE (IGNORE ,@ignores))
  236.                   ,resultvar
  237.               ) )
  238.             (let ((g (gensym))) (push g vars) (push g ignores))
  239.       ) ) )
  240.       `(PROGN ,form NIL)
  241.     )
  242.     `(NTH ,n (MULTIPLE-VALUE-LIST ,form))
  243. ) )
  244.  
  245. ;-------------------------------------------------------------------------------
  246.  
  247. ;; X3J13 vote <88>
  248.  
  249. ;; Interpretierte Funktion in Lambda-Ausdruck umwandeln, CLtL2 S. 682
  250. (defun function-lambda-expression (obj)
  251.   (unless (sys::closurep obj)
  252.     (error #+DEUTSCH "~: ~ ist keine Funktion."
  253.            #+ENGLISH "~: ~ is not a function"
  254.            'function-lambda-expression obj
  255.   ) )
  256.   (if (not (compiled-function-p obj))
  257.     (values (cons 'LAMBDA (sys::%record-ref obj 1)) ; Lambda-Ausdruck ohne Docstring
  258.             (vector ; Environment
  259.                     (sys::%record-ref obj 4) ; venv
  260.                     (sys::%record-ref obj 5) ; fenv
  261.                     (sys::%record-ref obj 6) ; benv
  262.                     (sys::%record-ref obj 7) ; genv
  263.                     (sys::%record-ref obj 8) ; denv
  264.             )
  265.             (sys::%record-ref obj 0) ; Name
  266.     )
  267.     (values nil t nil)
  268. ) )
  269.  
  270. ;-------------------------------------------------------------------------------
  271.  
  272. ;; X3J13 vote <52>
  273.  
  274. ;; Package-Definition und -Installation, CLtL2 S. 270
  275. (defmacro defpackage (packname &rest options)
  276.   (flet ((check-packname (name)
  277.            (cond ((stringp name) name)
  278.                  ((symbolp name) (symbol-name name))
  279.                  (t (error #+DEUTSCH "~S: Package-Name muß ein String oder Symbol sein, nicht ~S."
  280.                            #+ENGLISH "~S: package name ~S should be a string or a symbol"
  281.                            #+FRANCAIS "~S : Le nom d'un paquetage doit être une chaîne ou un symbole et non ~S."
  282.                            'defpackage name
  283.          ) )     )  )
  284.          (check-symname (name)
  285.            (cond ((stringp name) name)
  286.                  ((symbolp name) (symbol-name name))
  287.                  (t (error #+DEUTSCH "~S ~A: Symbol-Name muß ein String oder Symbol sein, nicht ~S."
  288.                            #+ENGLISH "~S ~A: symbol name ~S should be a string or a symbol"
  289.                            #+FRANCAIS "~S ~A : Le nom d'un symbole doit être une chaîne ou un symbole et non ~S."
  290.                            'defpackage packname name
  291.         )) )     )  )
  292.     (setq packname (check-packname packname))
  293.     ; Optionen abarbeiten:
  294.     (let ((size nil) ; Flag ob :SIZE schon da war
  295.           (nickname-list '()) ; Liste von Nicknames
  296.           (shadow-list '()) ; Liste von Symbolnamen für shadow
  297.           (shadowing-list '()) ; Listen von Paaren (Symbolname . Paketname) für shadowing-import
  298.           (use-list '()) ; Liste von Paketnamen für use-package
  299.           (use-default '("LISP")) ; Default-Wert für use-list
  300.           (import-list '()) ; Listen von Paaren (Symbolname . Paketname) für import
  301.           (intern-list '()) ; Liste von Symbolnamen für intern
  302.           (symname-list '()) ; Liste aller bisher aufgeführten Symbolnamen
  303.           (export-list '())) ; Liste von Symbolnamen für export
  304.       (flet ((record-symname (name)
  305.                (if (member name symname-list :test #'string=)
  306.                  (error #+DEUTSCH "~S ~A: Symbol ~A darf nur einmal aufgeführt werden."
  307.                         #+ENGLISH "~S ~A: the symbol ~A must not be specified more than once"
  308.                         #+FRANCAIS "~S ~A : Le symbole ~A ne peut être mentionné qu'une seule fois."
  309.                         'defpackage packname name
  310.                  )
  311.                  (push name symname-list)
  312.                )
  313.                name
  314.             ))
  315.         (dolist (option options)
  316.           (if (listp option)
  317.             (if (keywordp (car option))
  318.               (case (first option)
  319.                 (:SIZE
  320.                   (if size
  321.                     (error #+DEUTSCH "~S ~A: Die Option ~S darf nur einmal angegeben werden."
  322.                            #+ENGLISH "~S ~A: the ~S option must not be given more than once"
  323.                            #+FRANCAIS "~S ~A : L'option ~S ne doit apparaître qu'une seule fois."
  324.                            'defpackage packname ':SIZE
  325.                     )
  326.                     (setq size t) ; Argument wird ignoriert
  327.                 ) )
  328.                 (:NICKNAMES
  329.                   (dolist (name (rest option))
  330.                     (push (check-packname name) nickname-list)
  331.                 ) )
  332.                 (:SHADOW
  333.                   (dolist (name (rest option))
  334.                     (push (record-symname (check-symname name)) shadow-list)
  335.                 ) )
  336.                 (:SHADOWING-IMPORT-FROM
  337.                   (let ((pack (check-packname (second option))))
  338.                     (dolist (name (cddr option))
  339.                       (push (cons (record-symname (check-symname name)) pack)
  340.                             shadowing-list
  341.                 ) ) ) )
  342.                 (:USE
  343.                   (dolist (name (rest option))
  344.                     (push (check-packname name) use-list)
  345.                   )
  346.                   (setq use-default nil)
  347.                 )
  348.                 (:IMPORT-FROM
  349.                   (let ((pack (check-packname (second option))))
  350.                     (dolist (name (cddr option))
  351.                       (push (cons (record-symname (check-symname name)) pack)
  352.                             import-list
  353.                 ) ) ) )
  354.                 (:INTERN
  355.                   (dolist (name (rest option))
  356.                     (push (record-symname (check-symname name)) intern-list)
  357.                 ) )
  358.                 (:EXPORT
  359.                   (dolist (name (rest option))
  360.                     (push (check-symname name) export-list)
  361.                 ) )
  362.                 (T (error #+DEUTSCH "~S ~A: Die Option ~S gibt es nicht."
  363.                           #+ENGLISH "~S ~A: unknown option ~S"
  364.                           #+FRANCAIS "~S ~A : Option ~S non reconnue."
  365.                           'defpackage packname (first option)
  366.               ) )  )
  367.               (error #+DEUTSCH "~S ~A: Falsche Syntax in ~S-Option: ~S"
  368.                      #+ENGLISH "~S ~A: invalid syntax in ~S option: ~S"
  369.                      #+FRANCAIS "~S ~A : Mauvaise syntaxe dans l'option ~S: ~S"
  370.                      'defpackage packname 'defpackage option
  371.             ) )
  372.             (error #+DEUTSCH "~S ~A: Das ist keine ~S-Option: ~S"
  373.                    #+ENGLISH "~S ~A: not a ~S option: ~S"
  374.                    #+FRANCAIS "~S ~A : Ceci n'est pas une option ~S: ~S"
  375.                    'defpackage packname 'defpackage option
  376.         ) ) )
  377.         ; Auf Überschneidungen zwischen intern-list und export-list prüfen:
  378.         (setq symname-list intern-list)
  379.         (mapc #'record-symname export-list)
  380.       )
  381.       ; Listen umdrehen und Default-Werte eintragen:
  382.       (setq nickname-list (nreverse nickname-list))
  383.       (setq shadow-list (nreverse shadow-list))
  384.       (setq shadowing-list (nreverse shadowing-list))
  385.       (setq use-list (or use-default (nreverse use-list)))
  386.       (setq import-list (nreverse import-list))
  387.       (setq intern-list (nreverse intern-list))
  388.       (setq export-list (nreverse export-list))
  389.       ; Expansion produzieren:
  390.       `(EVAL-WHEN (LOAD COMPILE EVAL)
  391.          (IN-PACKAGE ,packname :NICKNAMES ',nickname-list)
  392.          ; Schritt 1
  393.          ,@(if shadow-list
  394.              `((SHADOW ',(mapcar #'make-symbol shadow-list) ,packname))
  395.            )
  396.          ,@(mapcar
  397.              #'(lambda (pair)
  398.                  `(SHADOWING-IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  399.                )
  400.              shadowing-list
  401.            )
  402.          ; Schritt 2
  403.          ,@(if use-list `((USE-PACKAGE ',use-list ,packname)))
  404.          ; Schritt 3
  405.          ,@(mapcar
  406.              #'(lambda (pair)
  407.                  `(IMPORT-CERROR ,(car pair) ,(cdr pair) ,packname)
  408.                )
  409.              import-list
  410.            )
  411.          ,@(if intern-list
  412.              `((MAPCAR #'INTERN ',(mapcar #'car intern-list) ',(mapcar #'cdr intern-list)))
  413.            )
  414.          ; Schritt 4
  415.          ,@(if export-list
  416.              `((INTERN-EXPORT ',export-list ,packname))
  417.            )
  418.          (FIND-PACKAGE ,packname)
  419.        )
  420. ) ) )
  421. ; Hilfsfunktionen:
  422. (defun find-symbol-cerror (string packname calling-packname)
  423.   (multiple-value-bind (sym found) (find-symbol string packname)
  424.     (unless found
  425.       (cerror #+DEUTSCH "Dieses Symbol wird erzeugt."
  426.               #+ENGLISH "This symbol will be created."
  427.               #+FRANCAIS "Ce symbole sera créé."
  428.               #+DEUTSCH "~S ~A: Es gibt kein Symbol ~A::~A ."
  429.               #+ENGLISH "~S ~A: There is no symbol ~A::~A ."
  430.               #+FRANCAIS "~S ~A : Il n'y a pas de symbole ~A::~A ."
  431.               'defpackage calling-packname packname string
  432.       )
  433.       (setq sym (intern string packname))
  434.     )
  435.     sym
  436. ) )
  437. (defun shadowing-import-cerror (string packname calling-packname)
  438.   (shadowing-import (find-symbol-cerror string packname calling-packname)
  439.                     calling-packname
  440. ) )
  441. (defun import-cerror (string packname calling-packname)
  442.   (import (find-symbol-cerror string packname calling-packname)
  443.           calling-packname
  444. ) )
  445. (defun intern-export (string-list packname)
  446.   (export (mapcar #'(lambda (string) (intern string packname)) string-list)
  447.           packname
  448. ) )
  449.  
  450. ;-------------------------------------------------------------------------------
  451.  
  452. ;; cf. X3J13 vote <173>
  453.  
  454. ;; Definition globaler Symbol-Macros
  455. (defmacro define-symbol-macro (symbol expansion)
  456.   (unless (symbolp symbol)
  457.     (error #+DEUTSCH "~S: Der Name eines Symbol-Macros  muß ein Symbol sein, nicht: ~S"
  458.            #+ENGLISH "~S: the name of a symbol macro must be a symbol, not ~S"
  459.            #+FRANCAIS "~S : Le nom d'un macro symbole doit être un symbole et non ~S"
  460.            'define-symbol-macro symbol
  461.   ) )
  462.   `(LET ()
  463.      (EVAL-WHEN (COMPILE LOAD EVAL)
  464.        (SET ',symbol (SYSTEM::MAKE-SYMBOL-MACRO ',expansion))
  465.      )
  466.      ',symbol
  467.    )
  468. )
  469.  
  470. ;-------------------------------------------------------------------------------
  471.  
  472. ;; X3J13 vote <40>
  473.  
  474. (defmacro print-unreadable-object
  475.     ((&whole args object stream &key type identity) &body body)
  476.   (declare (ignore object stream type identity))
  477.   `(SYSTEM::WRITE-UNREADABLE
  478.      ,(if body `(FUNCTION (LAMBDA () ,@body)) 'NIL)
  479.      ,@args
  480.    )
  481. )
  482.  
  483. ;-------------------------------------------------------------------------------
  484.  
  485. ;; X3J13 vote <144>
  486.  
  487. (defmacro declaim (&rest decl-specs)
  488.   `(PROCLAIM (QUOTE ,decl-specs))
  489. )
  490.  
  491. ;-------------------------------------------------------------------------------
  492.  
  493.